home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / init.lisp < prev    next >
Encoding:
Text File  |  1992-12-21  |  9.7 KB  |  259 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;;
  28. ;;; This file defines the initialization and related protocols.
  29. ;;; 
  30.  
  31. (in-package :pcl)
  32.  
  33. (defmethod make-instance ((class symbol) &rest initargs)
  34.   (apply #'make-instance (find-class class) initargs))
  35.  
  36. (defmethod make-instance ((class class) &rest initargs)
  37.   (unless (class-finalized-p class) (finalize-inheritance class))
  38.   (setq initargs (default-initargs class initargs))
  39.   #||
  40.   (check-initargs-1
  41.    class initargs
  42.    (list (list* 'allocate-instance class initargs)
  43.      (list* 'initialize-instance (class-prototype class) initargs)
  44.      (list* 'shared-initialize (class-prototype class) t initargs)))
  45.   ||#
  46.   (let* ((info (initialize-info class initargs))
  47.      (valid-p (initialize-info-valid-p info)))
  48.     (when (and (consp valid-p) (eq (car valid-p) :invalid))
  49.       (error "Invalid initialization argument ~S for class ~S"
  50.          (cdr valid-p) (class-name class))))
  51.   (let ((instance (apply #'allocate-instance class initargs)))
  52.     (apply #'initialize-instance instance initargs)
  53.     instance))
  54.  
  55. (defvar *default-initargs-flag* (list nil))
  56.  
  57. (defmethod default-initargs ((class slot-class) supplied-initargs)
  58.   (call-initialize-function
  59.    (initialize-info-default-initargs-function
  60.     (initialize-info class supplied-initargs))
  61.    nil supplied-initargs)
  62.   #||
  63.   ;; This implementation of default initargs is critically dependent
  64.   ;; on all-default-initargs not having any duplicate initargs in it.
  65.   (let ((all-default (class-default-initargs class))
  66.     (miss *default-initargs-flag*))
  67.     (flet ((getf* (plist key)
  68.          (do ()
  69.          ((null plist) miss)
  70.            (if (eq (car plist) key)
  71.            (return (cadr plist))
  72.            (setq plist (cddr plist))))))
  73.       (labels ((default-1 (tail)
  74.          (if (null tail)
  75.              nil
  76.              (if (eq (getf* supplied-initargs (caar tail)) miss)
  77.              (list* (caar tail)
  78.                 (funcall (cadar tail))
  79.                 (default-1 (cdr tail)))
  80.              (default-1 (cdr tail))))))
  81.     (append supplied-initargs (default-1 all-default)))))
  82.   ||#)
  83.  
  84. (defmethod initialize-instance ((instance slot-object) &rest initargs)
  85.   (apply #'shared-initialize instance t initargs))
  86.  
  87. (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
  88.   #||  
  89.   (check-initargs-1
  90.    (class-of instance) initargs
  91.    (list (list* 'reinitialize-instance instance initargs)
  92.      (list* 'shared-initialize instance nil initargs)))
  93.   ||#
  94.   (let* ((class (class-of instance))
  95.      (info (initialize-info class initargs))
  96.      (valid-p (initialize-info-ri-valid-p info)))
  97.     (when (and (consp valid-p) (eq (car valid-p) :invalid))
  98.       (error "Invalid initialization argument ~S for class ~S"
  99.          (cdr valid-p) (class-name class))))
  100.   (apply #'shared-initialize instance nil initargs)
  101.   instance)
  102.  
  103. (defmethod update-instance-for-different-class ((previous standard-object)
  104.                         (current standard-object)
  105.                         &rest initargs)
  106.   ;; First we must compute the newly added slots.  The spec defines
  107.   ;; newly added slots as "those local slots for which no slot of
  108.   ;; the same name exists in the previous class."
  109.   (let ((added-slots '())
  110.     (current-slotds (class-slots (class-of current)))
  111.     (previous-slot-names (mapcar #'slot-definition-name
  112.                      (class-slots (class-of previous)))))
  113.     (dolist (slotd current-slotds)
  114.       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
  115.            (eq (slot-definition-allocation slotd) ':instance))
  116.       (push (slot-definition-name slotd) added-slots)))
  117.     (check-initargs-1
  118.      (class-of current) initargs
  119.      (list (list* 'update-instance-for-different-class previous current initargs)
  120.        (list* 'shared-initialize current added-slots initargs)))
  121.     (apply #'shared-initialize current added-slots initargs)))
  122.  
  123. (defmethod update-instance-for-redefined-class ((instance standard-object)
  124.                         added-slots
  125.                         discarded-slots
  126.                         property-list
  127.                         &rest initargs)
  128.   (check-initargs-1
  129.    (class-of instance) initargs
  130.    (list (list* 'update-instance-for-redefined-class
  131.         instance added-slots discarded-slots property-list initargs)
  132.      (list* 'shared-initialize instance added-slots initargs)))
  133.   (apply #'shared-initialize instance added-slots initargs))
  134.  
  135. (defmethod shared-initialize
  136.     ((instance slot-object) slot-names &rest initargs)
  137.   (when (eq slot-names 't)
  138.     (return-from shared-initialize
  139.       (call-initialize-function
  140.        (initialize-info-shared-initialize-t-function
  141.     (initialize-info (class-of instance) initargs))
  142.        instance initargs)))
  143.   (when (eq slot-names 'nil)
  144.     (return-from shared-initialize
  145.       (call-initialize-function
  146.        (initialize-info-shared-initialize-nil-function
  147.     (initialize-info (class-of instance) initargs))
  148.        instance initargs)))
  149.   ;;
  150.   ;; initialize the instance's slots in a two step process
  151.   ;;   (1) A slot for which one of the initargs in initargs can set
  152.   ;;       the slot, should be set by that initarg.  If more than
  153.   ;;       one initarg in initargs can set the slot, the leftmost
  154.   ;;       one should set it.
  155.   ;;
  156.   ;;   (2) Any slot not set by step 1, may be set from its initform
  157.   ;;       by step 2.  Only those slots specified by the slot-names
  158.   ;;       argument are set.  If slot-names is:
  159.   ;;       T
  160.   ;;            any slot not set in step 1 is set from its
  161.   ;;            initform
  162.   ;;       <list of slot names>
  163.   ;;            any slot in the list, and not set in step 1
  164.   ;;            is set from its initform
  165.   ;;
  166.   ;;       ()
  167.   ;;            no slots are set from initforms
  168.   ;;
  169.   (let* ((class (class-of instance))
  170.      (slotds (class-slots class))
  171.      #-new-kcl-wrapper
  172.      (std-p (or (std-instance-p instance) (fsc-instance-p instance))))
  173.     (dolist (slotd slotds)
  174.       (let ((slot-name (slot-definition-name slotd))
  175.         (slot-initargs (slot-definition-initargs slotd)))
  176.     (unless (progn
  177.           ;; Try to initialize the slot from one of the initargs.
  178.           ;; If we succeed return T, otherwise return nil.
  179.           (doplist (initarg val) initargs
  180.                (when (memq initarg slot-initargs)
  181.                  (setf (slot-value-using-class class instance slotd)
  182.                    val)
  183.                  (return 't))))
  184.       ;; Try to initialize the slot from its initform.
  185.       (if (and slot-names
  186.            (or (eq slot-names 't)
  187.                (memq slot-name slot-names))
  188.            (or #-new-kcl-wrapper (and (not std-p) (eq slot-names 't))
  189.                (not (slot-boundp-using-class class instance slotd))))
  190.           (let ((initfunction (slot-definition-initfunction slotd)))
  191.         (when initfunction
  192.           (setf (slot-value-using-class class instance slotd)
  193.             (funcall initfunction))))))))
  194.     instance))
  195.  
  196.  
  197. ;;; 
  198. ;;; if initargs are valid return nil, otherwise signal an error
  199. ;;;
  200. (defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t))
  201.   (multiple-value-bind (legal allow-other-keys)
  202.       (check-initargs-values class call-list)
  203.     (unless allow-other-keys
  204.       (if plist-p
  205.       (check-initargs-2-plist initargs class legal error-p)
  206.       (check-initargs-2-list initargs class legal error-p)))))
  207.  
  208. (defun check-initargs-values (class call-list)
  209.   (let ((methods (mapcan #'(lambda (call)
  210.                  (if (consp call)
  211.                  (copy-list (compute-applicable-methods
  212.                          (gdefinition (car call))
  213.                          (cdr call)))
  214.                  (list call)))
  215.              call-list))
  216.     (legal (apply #'append (mapcar #'slot-definition-initargs
  217.                        (class-slots class)))))
  218.     ;; Add to the set of slot-filling initargs the set of
  219.     ;; initargs that are accepted by the methods.  If at
  220.     ;; any point we come across &allow-other-keys, we can
  221.     ;; just quit.
  222.     (dolist (method methods)
  223.       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
  224.       (analyze-lambda-list (if (consp method)
  225.                    (early-method-lambda-list method)
  226.                    (method-lambda-list method)))
  227.     (declare (ignore nreq nopt keysp restp))
  228.     (when allow-other-keys
  229.       (return-from check-initargs-values (values nil t)))
  230.     (setq legal (append keys legal))))
  231.     (values legal nil)))
  232.  
  233. (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
  234.   (unless (getf initargs :allow-other-keys)
  235.     ;; Now check the supplied-initarg-names and the default initargs
  236.     ;; against the total set that we know are legal.
  237.     (doplist (key val) initargs
  238.        (unless (memq key legal)
  239.      (if error-p
  240.          (error "Invalid initialization argument ~S for class ~S"
  241.             key
  242.             (class-name class))
  243.          (return-from check-initargs-2-plist nil)))))
  244.   t)
  245.  
  246. (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
  247.   (unless (memq :allow-other-keys initkeys)
  248.     ;; Now check the supplied-initarg-names and the default initargs
  249.     ;; against the total set that we know are legal.
  250.     (dolist (key initkeys)
  251.       (unless (memq key legal)
  252.     (if error-p
  253.         (error "Invalid initialization argument ~S for class ~S"
  254.            key
  255.            (class-name class))
  256.         (return-from check-initargs-2-list nil)))))
  257.   t)
  258.  
  259.